home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / hyp.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  45.5 KB  |  1,863 lines
  1. ;;;  -*- LISP -*-
  2. ;;;    ** (c) Copyright 1979 Massachusetts Institute of Technology **
  3.  
  4. (in-package "MAXIMA")
  5.  
  6. (macsyma-module hyp)
  7.  
  8. (eval-when (compile eval)
  9. (declare-top (special fun w b l alglist $true $false n  c l1 l2))
  10. )
  11. (DECLARE-TOP (SPECIAL VAR PAR ZEROSIGNTEST PRODUCTCASE 
  12.           FLDEG FLGKUM CHECKCOEFSIGNLIST SERIESLIST
  13.           $EXPONENTIALIZE $BESTRIGLIM $RADEXPAND FAIL-SYM)
  14.          )
  15.  
  16.  
  17. ;; (eval-when (compile eval) (load '((dsk ell) macros >)) )
  18.  
  19. (declare-top (special fldeg flgkum listcmdiff checkcoefsignlist serieslist
  20.               fl1f1))
  21. (SETQ FLGKUM T FLDEG T FL1F1 T CHECKCOEFSIGNLIST NIL)
  22.  
  23. (declare-top (special $exponentialize $bestriglim $radexpand))
  24.  
  25. (setq fail-sym (gensym))
  26. (defvar 3//2 '((rat simp) 3 2))
  27. (defvar 1//2 '((rat simp) 1 2))
  28. (defvar -1//2 '((rat simp) -1 2))
  29.  
  30. (eval-when (eval compile)
  31. (defmacro fixp (x) `(typep ,x 'fixnum))
  32.  
  33. (setq FLGKUM T FLDEG T FL1F1 T CHECKCOEFSIGNLIST ()
  34. ;;      $BESTRIGLIM 3. $RADEXPAND '$ALL
  35.       FAIL-SYM (GENSYM))
  36.  
  37. (DEFMACRO SIMP (X) `(SIMPLIFYA ,X ()))
  38.  
  39. (DEFMACRO SIMP-LIST (L) `(MAPCAR #'(LAMBDA (X) (SIMP X)) ,L))
  40.  
  41. ; The macro MABS has been renamed to HYP-MABS in order to
  42. ; avoid conflict with the Maxima symbol MABS. The other
  43. ; M* macros defined here should probably be similarly renamed
  44. ; for consistency. jfa 03/27/2002
  45.  
  46. (DEFMACRO HYP-MABS (X) `(SIMP `((MABS) ,,X)))
  47.  
  48. (DEFMACRO MSQRT (X) `(M^T ,X 1//2))
  49.  
  50. (DEFMACRO MEXPT (X) `(M^T '$%E ,X))
  51.  
  52. (DEFMACRO MLOG (X) `(SIMP `((%LOG) ,,X)))
  53.  
  54. (DEFMACRO MSIN (X) `(SIMP `((%SIN) ,,X)))
  55.  
  56. (DEFMACRO MCOS (X) `(SIMP `((%COS) ,,X)))
  57.  
  58. (DEFMACRO MASIN (X) `(SIMP `((%ASIN) ,,X)))
  59.  
  60. (DEFMACRO MATAN (X) `(SIMP `((%ATAN) ,,X)))
  61.  
  62. (DEFMACRO MGAMMA (X) `(SIMP `((%GAMMA) ,,X)))
  63.  
  64. (DEFMACRO MBINOM (X Y) `(SIMP `((%BINOMIAL) ,,X ,,Y)))
  65.  
  66. (DEFMACRO MERF (X) `(SIMP `((%ERF) ,,X)))
  67.  
  68. (DEFMACRO =1//2 (X) `(ALIKE1 ,X 1//2))
  69.  
  70. (DEFMACRO =3//2 (X) `(ALIKE1 ,X 3//2))
  71.  
  72. (DEFMACRO =-1//2 (X) `(ALIKE1 ,X -1//2))
  73. )
  74.  
  75.  
  76. (DEFUN $HGFRED
  77.        (L1 L2 ARG &aux ($bestriglim 3) ($radexpand '$all))
  78.        (prog()
  79.         (setq var arg par arg)
  80.         (return (HGFSIMP-EXEC (CDR L1)(CDR L2) ARG))))
  81.  
  82.  
  83. (DEFUN HGFSIMP-EXEC
  84.        (L1 L2 ARG)
  85.        (setq l1 (copy-tree l1) l2 (copy-tree l2))
  86.        (PROG (RES $exponentialize)
  87.          (SETQ  RES
  88.            (HGFSIMP L1 L2 ARG))
  89.          (COND ((OR (NUMBERP RES)(NOT (ATOM RES)))
  90.             (RETURN RES)))
  91.          (RETURN (FPQFORM L1 L2 ARG))))
  92.  
  93.  
  94. (DEFUN HGFSIMP
  95.        (L1 L2 VAR)
  96.        (PROG (RESIMP )
  97.         (SETQ L1
  98.           (MACSIMP L1)
  99.           L2
  100.           (MACSIMP L2)
  101.           RESIMP
  102.           (SIMPG L1 L2))
  103.         
  104.         (COND ((NOT (EQ (CAR RESIMP) 'FAIL))(RETURN RESIMP)))
  105.         (COND ((SETQ LISTCMDIFF
  106.              (INTDIFFL1L2 (CADR RESIMP)
  107.                       (CADDR RESIMP)))
  108.            (return (splitpfq listcmdiff
  109.                      (cadr resimp)
  110.                      (caddr resimp)))))
  111.         (RETURN (DISPATCH-SPEC-SIMP (CADR RESIMP)
  112.                     (CADDR RESIMP)))))
  113.  
  114.  
  115.  
  116. (DEFUN MACSIMP
  117.        (L)
  118.  
  119.        (COND ((NULL L) NIL)
  120.          (T (APPEND (LIST (SIMPLIFYA (CAR L) NIL)) (CDR L)))))
  121.  
  122.  
  123. (DEFUN SIMPG
  124.        (L1 L2)
  125.        (PROG(IL)
  126.         (COND ((NULL (SETQ IL (zl-INTERSECTION L1 L2)))
  127.            (RETURN (SIMPG-EXEC L1 L2))))
  128.         (RETURN (SIMPG-EXEC (DEL IL L1)(DEL IL L2)))))   
  129.  
  130.  
  131. (DEFUN DEL
  132.        (A B)
  133.        (COND ((NULL A) B)(T (DEL (CDR A) (ZL-DELETE (CAR A) B 1)))))
  134.  
  135.  
  136. (DEFUN SIMPG-EXEC
  137.        (L1 L2)
  138.        (PROG(N)
  139.         (COND ((ZEROP-IN-L L1)(RETURN 1)))
  140.         (COND ((SETQ N (hyp-NEGP-IN-L L1))
  141.            (RETURN (CREATE-POLY L1 L2 N))))
  142.         (COND ((OR (ZEROP-IN-L L2)(hyp-NEGP-IN-L L2))
  143.            (RETURN 'UNDEF)))
  144.         (RETURN (APPEND (LIST 'FAIL)(LIST L1)(LIST L2)))))
  145.             
  146.  
  147. (DEFUN INTDIFFL1L2
  148.        (L1 L2)
  149.        (COND ((NULL L1)  NIL)(T (INTDIFF L1 L2))))
  150.  
  151. (DEFUN INTDIFF
  152.        (L1 L2)
  153.        (PROG(L A DIF)
  154.         (SETQ L L2 A (CAR L1))
  155.         JUMP
  156.         (COND ((NULL L)(RETURN (INTDIFFL1L2 (CDR L1) L2))))
  157.         (COND ((NNI (SETQ DIF (SUB A (CAR L))))
  158.            (RETURN (LIST A DIF))))
  159.         (SETQ L (CDR L))
  160.         (GO JUMP)))             
  161.  
  162.  
  163. (DEFUN CREATE-POLY
  164.        (L1 L2 N)
  165.        ((LAMBDA(LEN1 LEN2)
  166.            (COND ((AND (EQual LEN1 2)(EQual LEN2 1))
  167.               (2F1POLYS L1 L2 N))
  168.              ((AND (EQual LEN1 1)(EQual LEN2 1))
  169.               (1F1POLYS L2 N))
  170.              ((AND (EQual LEN1 2)(ZEROP LEN2))
  171.               (2F0POLYS L1 N))
  172.              (T (CREATE-ANY-POLY L1 L2 (mul -1 N)))))
  173.     (LENGTH L1)
  174.     (LENGTH L2)))
  175.  
  176.  
  177. (DEFUN 1F1POLYS
  178.        (L2 N)
  179.        (PROG(C FACT1 FACT2)
  180.         (SETQ C
  181.           (CAR L2)
  182.           N
  183.           (MUL -1 N)
  184.           FACT1
  185.           (MUL (POWER 2 N)
  186.                (FACTORIAL N)
  187.                (INV (POWER -1 N)))
  188.           FACT2
  189.           (MUL (POWER 2 (INV 2))(POWER VAR (INV 2))))
  190.         (COND ((EQUAL C (DIV 1 2))
  191.            (RETURN (MUL FACT1
  192.                 (INV (FACTORIAL (ADD N N)))
  193.                 (HERMPOL (ADD N N) FACT2)))))
  194.         (COND ((EQUAL C (DIV 3 2))
  195.            (RETURN (MUL FACT1
  196.                 (INV (FACTORIAL (ADD N N 1)))
  197.                 (HERMPOL (ADD N N 1) FACT2)))))
  198.         (RETURN (MUL (FACTORIAL N)
  199.              (GM C)
  200.              (GM (ADD C N))
  201.              (LAGPOL N (SUB C 1) VAR)))))
  202.  
  203.  
  204. (DEFUN HERMPOL(N ARG)(LIST '(MQAPPLY)(LIST '($%HE ARRAY) N) ARG))
  205. (DEFUN LAGPOL(N A ARG)(LIST '(MQAPPLY)(LIST '($%L ARRAY) N A) ARG))
  206.  
  207.  
  208. (DEFUN 2F0POLYS
  209.        (L1 N)
  210.        (PROG(A B TEMP X)
  211.         (SETQ A (CAR L1) B (CADR L1))
  212.         (COND ((EQUAL (SUB B A)(DIV -1 2))
  213.            (SETQ TEMP A A B B TEMP)))
  214.         (COND ((EQUAL (SUB B A)(DIV 1 2))
  215.            (SETQ X (POWER (DIV 2 (MUL -1 VAR))(INV 2)))
  216.            (RETURN (INTERHERMPOL N A B X))))
  217.         (SETQ X (MUL -1 (INV VAR)) N (MUL -1 N))
  218.         (RETURN (MUL (FACTORIAL N)
  219.              (INV (POWER X N))
  220.              (INV (POWER -1 N))
  221.              (LAGPOL N (ADD B N) X)))))
  222.  
  223. (DEFUN INTERHERMPOL
  224.        (N A B X)
  225.        (PROG(FACT)
  226.         (SETQ FACT (POWER X (MUL -1 N)))
  227.         (COND ((EQUAL A N)
  228.            (SETQ N (MUL -2 N))
  229.            (RETURN (MUL FACT (HERMPOL N X)))))
  230.         (COND ((EQUAL B N)
  231.            (SETQ N (SUB 1 (ADD N N)))
  232.            (RETURN (MUL FACT (HERMPOL N X)))))))
  233.  
  234.  
  235. (DEFUN 2F1POLYS
  236.        (L1 L2 N)
  237.        (PROG(L V LGF)
  238.         (COND ((NOT (EQ (CAR L1) N))(setq l1 (REVERSE L1))))
  239.         (SETQ L (VFVP (DIV (ADD (CADR L1) N) 2)))
  240.         (SETQ V (CDR (ZL-assoc 'V L)))
  241.         
  242.         (cond ((setq lgf (legpol (car l1)(cadr l1)(car l2)))
  243.            (return lgf)))
  244.         (COND ((EQUAL (SUB (CAR L2) V) '((RAT SIMP) 1 2))
  245.            (RETURN (mul 
  246.                 (cond ((zerp v) 1)
  247.                       (t (mul (factorial (* -1 n))
  248.                           (inv (factf (mul 2 v)(* -1 n))))))
  249.                 (GEGENPOL (mul -1 N)
  250.                       V
  251.                       (SUB 1 (MUL 2 PAR)))))))
  252.         (RETURN (mul (factorial (* -1 n))
  253.              (inv (factf (add 1 v) (* -1 n)))
  254.              (JACOBPOL (mul -1 N)
  255.                    (ADD (CAR L2) -1)
  256.                    (SUB (MUL 2 V)(CAR L2))
  257.                    (SUB 1 (MUL 2 PAR)))))))
  258.  
  259.  
  260. (DEFUN JACOBPOL
  261.        (N A B X)
  262.        (LIST '(MQAPPLY)(LIST '($%P ARRAY) N A B) X))
  263.  
  264.  
  265. (DEFUN GEGENPOL(N V X)
  266.        (cond ((equal v 0) (tchebypol n x))
  267.          (t (LIST '(MQAPPLY)(LIST '($%C ARRAY) N V) X)))) 
  268. (defun legenpol(n x)(list '(mqapply)(list '($%P array) n) x))
  269. (defun tchebypol (n x)(list '(mqapply)(list '($%T array) n) x))
  270. (DEFUN CREATE-ANY-POLY
  271.        (L1 L2 N)
  272.        (PROG(RESULT EXP PRODNUM PRODEN)
  273.         (SETQ RESULT 1 PRODNUM 1 PRODEN 1 EXP 1)
  274.         LOOP
  275.         (COND ((ZEROP N) (RETURN RESULT)))
  276.         (SETQ PRODNUM
  277.           (MUL PRODNUM (MULL L1))
  278.           PRODEN
  279.           (MUL PRODEN (MULL L2)))
  280.         (SETQ RESULT
  281.           (ADD RESULT
  282.                (MUL PRODNUM
  283.                 (POWER VAR EXP)
  284.                 (INV PRODEN)
  285.                 (INV (FACTORIAL EXP)))))
  286.         (SETQ N
  287.           (sub N 1)
  288.           EXP
  289.           (add EXP 1)
  290.           L1
  291.           (INCR1 L1)
  292.           L2
  293.           (INCR1 L2))
  294.         (GO LOOP)))
  295.  
  296.  
  297. (DEFUN MULL(L)(COND ((NULL L) 1)(T (MUL (CAR L)(MULL (CDR L))))))
  298.  
  299.  
  300. (DEFUN INCR1
  301.        (L)
  302.        (COND ((NULL L) NIL)
  303.          (T (APPEND (LIST (ADD (CAR L) 1))(INCR1 (CDR L))))))
  304.  
  305.  
  306. (DEFUN DISPATCH-SPEC-SIMP
  307.        (L1 L2)
  308.        (PROG(LEN1 LEN2)
  309.         (SETQ LEN1 (LENGTH L1) LEN2 (LENGTH L2))
  310.         (COND ((AND (LESSP LEN1 2)(LESSP LEN2 2))
  311.            (RETURN (SIMP2>F<2 L1 L2 LEN1 LEN2))))
  312.         (COND ((AND (EQUAL LEN1 2)(EQUAL LEN2 1))
  313.            (RETURN (SIMP2F1 L1 L2))))
  314.         (RETURN (FPQFORM L1 L2 VAR))))
  315.  
  316.  
  317. (DEFUN SIMP2>F<2
  318.        (L1 L2 LEN1 LEN2)
  319.        (PROG()
  320.         (COND ((AND (ZEROP LEN1)(ZEROP LEN2))
  321.            (RETURN (POWER '$%E VAR))))
  322.         (COND ((AND (ZEROP LEN1)(EQUAL LEN2 1))
  323.            (RETURN (BEStrig (CAR L2) VAR))))
  324.         (COND ((ZEROP LEN2)(RETURN (BINOM (CAR L1)))))
  325.         (RETURN (CONFL L1 L2 var))))
  326.  
  327.  
  328.         
  329.  
  330. (DEFUN BEStrig
  331.        (A X)
  332.        (prog (n res)
  333.          (setq res (mul (gm a) (power x (div (sub 1 a) 2))))
  334.          (COND ((AND (MAXIMA-INTEGERP (ADD A A))
  335.              (NUMBERP (SETQ N (SUB A (INV 2))))
  336.              (LESSP N $bestriglim))
  337.             (return (mul res
  338.                  (MEVAL (BESREDTRIG (- N 1)
  339.                             (mul 2
  340.                              '$%I
  341.                              (power
  342.                               x
  343.                               (inv
  344.                                2)))))))))
  345.          (cond ((equal (checksigntm x) '$negative)
  346.             (return (mul res
  347.              (BES (SUB A 1) (setq X (mul -1 x)) 'J)))))
  348.          (return (mul res (BES (SUB A 1) X 'I)))))
  349.         
  350.         
  351.  
  352. (DEFUN BES
  353.        (A X FLG)
  354.        (LIST '(MQAPPLY)
  355.          (LIST (COND ((EQ FLG 'J) '($%J ARRAY))
  356.              (T '($%IBES ARRAY)))
  357.            A)
  358.          (MUL 2 (POWER X (INV 2)))))
  359.  
  360.  
  361.  
  362.  
  363. (DEFUN BESREDTRIG
  364.        (N Z)
  365.        (COND ((MINUSP N)(TRIGREDMINUS (MUL -1 (ADD1 N)) Z))
  366.          (T (TRIGREDPLUS N Z))))
  367. (DEFUN TRIGREDPLUS
  368.        (N Z)
  369.        ((LAMBDA(NPINV2)
  370.            (MUL (CTR Z)
  371.             (ADD (MUL (SIN% (SUB Z NPINV2))
  372.                   (FIRSTSUM N Z))
  373.              (MUL (COS% (SUB Z NPINV2))
  374.                   (SECONDSUM N Z)))))
  375.     (MUL N '$%PI (INV 2))))
  376.  
  377.  
  378. (DEFUN TRIGREDMINUS
  379.        (N Z)
  380.        ((LAMBDA(NPINV2)
  381.            (MUL (CTR Z)
  382.             (SUB (MUL (COS% (ADD Z NPINV2))
  383.                   (FIRSTSUM N Z))
  384.              (MUL (SIN% (ADD Z NPINV2))
  385.                   (SECONDSUM N Z)))))
  386.     (MUL N '$%PI (INV 2))))
  387.  
  388. (DEFUN FIRSTSUM
  389.        (N Z)
  390.        (PROG(COUNT RESULT 2R N1)
  391.         (SETQ N1 ($ENTIER (DIV N 2)) COUNT 0 RESULT 1)
  392.         LOOP
  393.         (COND ((EQ COUNT N1)(RETURN RESULT)))
  394.         (SETQ COUNT
  395.           (ADD1 COUNT)
  396.           2R
  397.           (ADD COUNT COUNT)
  398.           RESULT
  399.           (ADD RESULT
  400.                (DIV (MUL (POWER -1 COUNT)
  401.                  (FACTORIAL (ADD N 2R)))
  402.                 (MUL (FACTORIAL 2R)
  403.                  (FACTORIAL (SUB N 2R))
  404.                  (POWER (ADD Z Z) 2R)))))
  405.         (GO LOOP)))
  406.  
  407. (DEFUN SECONDSUM
  408.        (N Z)
  409.        (PROG(COUNT RESULT 2R+1 N1)
  410.         (SETQ N1
  411.           ($ENTIER (DIV (SUB1 N) 2))
  412.           COUNT
  413.           0
  414.           RESULT
  415.           (INV Z))
  416.         (COND ((EQual N1 -1)(RETURN 0)))
  417.         LOOP
  418.         (COND ((EQ COUNT N1)(RETURN RESULT)))
  419.         (SETQ COUNT
  420.           (ADD1 COUNT)
  421.           2R+1
  422.           (ADD COUNT COUNT 1)
  423.           RESULT
  424.           (ADD RESULT
  425.                (DIV (MUL (POWER -1 COUNT)
  426.                  (FACTORIAL (ADD N 2R+1)))
  427.                 (MUL (FACTORIAL 2R+1)
  428.                  (FACTORIAL (SUB N 2R+1))
  429.                  (POWER (ADD Z Z) 2R+1)))))
  430.         (GO LOOP)))
  431.  
  432. (DEFUN CTR(Z)(POWER (DIV 2 (MUL '$%PI Z))(INV 2)))
  433.  
  434. (DEFUN NEGCOEF
  435.        (X)
  436.        (PROG(D)
  437.         (COND ((NULL (SETQ D (CDR (ZL-REMPROP 'D (D*U X)))))
  438.            (RETURN T)))
  439.         (COND ((EQ (ASKSIGN (INV D)) '$POSITIVE)
  440.            (RETURN NIL)))
  441.         (RETURN T)))
  442.  
  443.  
  444. (DEFUN BINOM(A)(POWER (SUB 1 VAR) (MUL -1 A)))
  445.  
  446.  
  447.  
  448. (DEFUN KUMMER
  449.        (L1 L2)
  450.        (MUL (LIST '(MEXPT) '$%E VAR)
  451.         (confl (LIST (SUB (CAR L2)(CAR L1))) L2 (MUL -1 VAR))))
  452.  
  453.  
  454. (DEFUN ZEROP-IN-L
  455.        (L)
  456.        (COND ((NULL L) NIL)
  457.          ((NUMBERP (CAR L))
  458.           (COND ((ZEROP (CAR L)) T)(T (ZEROP-IN-L (CDR L)))))
  459.          (T (ZEROP-IN-L (CDR L)))))
  460.  
  461.  
  462. (DEFUN hyp-NEGP-IN-L
  463.        (L)
  464.        (COND ((NULL L) NIL)
  465.          ((MAXIMA-INTEGERP (CAR L))
  466.           (COND ((MINUSP (CAR L)) (CAR L))
  467.             (T (hyp-NEGP-IN-L (CDR L)))))
  468.          (T (hyp-NEGP-IN-L (CDR L)))))
  469.  
  470.  
  471. (DEFUN zl-INTERSECTION
  472.        (L1 L2)
  473.        (cond ((null l1) nil)
  474.          ((zl-member (car l1) l2)
  475.           (cons (car l1)
  476.             (zl-intersection (cdr l1)
  477.                   (zl-delete (car l1) l2 1))))
  478.          (t (zl-intersection (cdr l1) l2))))
  479.  
  480. (DEFUN 2INP
  481.        (L)
  482.        (PROG(COUNT)
  483.         (SETQ COUNT 0)
  484.         LOOP
  485.         (COND ((AND (NULL L)(GREATERP COUNT 1))(RETURN T)))
  486.         (COND ((NULL L)(RETURN NIL)))
  487.         (COND ((MAXIMA-INTEGERP (CAR L))(SETQ COUNT (ADD1 COUNT))))
  488.         (SETQ L (CDR L))
  489.         (GO LOOP)))
  490.  
  491.  
  492. (DEFUN 2RATP
  493.        (L)
  494.        (PROG(COUNT)
  495.         (SETQ COUNT 0)
  496.         LOOP
  497.         (COND ((AND (NULL L)(GREATERP COUNT 1))(RETURN T)))
  498.         (COND ((NULL L)(RETURN NIL)))
  499.         (COND ((EQ (CAAAR L) 'RAT)(SETQ COUNT (ADD1 COUNT))))
  500.         (SETQ L (CDR L))
  501.         (GO LOOP)))
  502. ;2NUMP SHOULD BE ELIMINATED. IT IS NOT EFFICIENT TO USE ANYTHING ELSE BUT JUST CONVERTING TO RAT REPRESENTATION ALL 0.X ,X IN N. ESPECIALLY LATER WHEN WE CONVERT TO OMONIMA FOR TESTING TO FIND THE RIGHT FORMULA
  503.  
  504.  
  505. (DEFUN 2NUMP
  506.        (L)
  507.        (PROG(COUNT)
  508.         (SETQ COUNT 0)
  509.         LOOP
  510.         (COND ((AND (NULL L)(GREATERP COUNT 1))(RETURN T)))
  511.         (COND ((NULL L)(RETURN NIL)))
  512.         (COND ((NUMBERP (CAR L))(SETQ COUNT (ADD1 COUNT))))
  513.         (SETQ L (CDR L))
  514.         (GO LOOP)))
  515.  
  516.  
  517. (DEFUN WHITFUN(K M VAR)(LIST '(MQAPPLY)(LIST '($%M ARRAY) K M) VAR))
  518.  
  519. (DEFUN SIMP2F1
  520.        (L1 L2)
  521.        (PROG(A B C LGF)
  522.         (SETQ A (CAR L1) B (CADR L1) C (CAR L2))
  523.         (cond ((and (equal a 1)
  524.             (equal b 1)
  525.             (equal c 2))
  526.            (return (mul (inv (mul -1 var))
  527.                 ($log (add 1 (mul -1 var)))))))
  528.         (cond ((or (equal c  (div 3 2))
  529.                (equal c  (div 1 2)))
  530.            (cond ((setq lgf (trig-log (list a b) (list c)))
  531.               (return lgf)))))
  532.         
  533.         (cond ((or
  534.             (equal (sub a b) (div 1 2))
  535.             (equal (sub b a) (div 1 2)))
  536.            (cond ((setq lgf (hyp-cos a b c))(return lgf)))))
  537.         (cond ((and (maxima-integerp a)
  538.             (maxima-integerp b) (maxima-integerp c))
  539.            (return (simpr2f1 (list a b) (list c)))))
  540.         (cond ((and (maxima-integerp (add c (inv 2)))
  541.             (maxima-integerp (add a b)))
  542.            (return (step4 a b c))))
  543.         (cond ((maxima-integerp (add (sub a b) (inv 2)))
  544.            (cond ((setq lgf (step7 a b c))
  545.               (return lgf)))))
  546.         (COND ((SETQ LGF (LEGFUN A B C))(RETURN LGF)))
  547.         (PRINT 'SIMP2F1-WILL-CONTINUE-IN)
  548.         (RETURN  (FPQFORM L1 L2 VAR))))
  549.  
  550. (defun step7 (a b c)
  551.        (prog (l m n k mn kl sym sym1 r)
  552.          (setq l (s+c a)
  553.            sym (cdras 'f l)
  554.            mn  (cdras 'c l)
  555.            l (s+c c)
  556.            sym1 (cdras 'f l))
  557.          (cond ((not (equal (mul sym 2) sym1))(return nil)))
  558.          (setq kl (cdras 'c l)
  559.            l  (s+c b)
  560.            r (sub (add (inv 2) (cdras 'c l)) mn)
  561.            m ($num mn)
  562.            n ($denom mn)
  563.            k ($num kl)
  564.            l ($denom kl))
  565.          (cond ((equal (* 2 l) n)
  566.             (cond ((maxima-integerp (// (- k m) n))
  567.                (return (hyp-algv k l m n a b c))))))
  568.          (cond ((maxima-integerp (// k (* 2 l)))
  569.             (cond ((maxima-integerp (// m n))
  570.                (return (hyp-algv k l m n a b c)))
  571.               (t (return nil))))
  572.            ((maxima-integerp (// m n))
  573.                (return nil))
  574.            ((maxima-integerp (/ (- (* k n) (* 2 l m)) (* 2 l n)))
  575.             (return (hyp-algv k l m n a b c))))
  576.          (return nil)))
  577.  
  578. (defun getxy
  579.        (k l m n)
  580.        (prog (x y)
  581.          (setq y 0)
  582.          loop
  583.          (cond ((maxima-integerp (setq x
  584.                     (// (+ y
  585.                        (// k l)
  586.                        (* -2 (// m n)))
  587.                     2)))
  588.             (return (list x y))))
  589.          (setq y (+ 2 y))
  590.          (go loop)))
  591.  
  592. (defun hyp-algv  (k l m n a b c)
  593.        (prog (x y xy a-b)
  594.          (setq a-b (- a b))
  595.          (setq xy (getxy k l m n)
  596.            x (car xy)
  597.            y (cdr xy))
  598.          (cond ((< x 0)(go out)))
  599.          (cond ((< x y)(cond ((< (+ a-b x (inv 2)) 0)
  600.                   (return (f88 x y a c fun)))
  601.                  (t (return (f87 x y a c fun)))))
  602.            (t (cond ((< (+ a-b x (inv 2)) 0)
  603.                  (return (f90 x y a c fun)))
  604.                 (t (return (f89 x y a c fun))))))
  605.          out
  606.          (setq w (* x -1))
  607.          (cond ((< (- (+ a-b (inv 2)) w) 0)
  608.             (return (f92 x y a c fun)))
  609.            (t (return (f91 x y a c fun))))))
  610.  
  611. (defun f87 (x y a c fun )
  612.        (mul
  613.     (inv (mul (factf c y)
  614.           (factf (sub (add c y) (add a x)) (- x y))
  615.           (factf (sub (add c y) (add a x (inv 2)))
  616.              (sub (add a x (inv 2)) (add a (inv 2))))))
  617.     (power 'ell (sub 1 c))
  618.     (power (sub 1 'ell)(sub (add y c) (add a (inv 2))))
  619.     ($diff (mul (power 'ell (add a x))
  620.             (power (sub 1 'ell)(mul -1 a))
  621.             ($diff (mul (power 'ell (sub (add (inv 2) x) y))
  622.                 ($diff (mul (power 'ell (sub (add c y) 1))
  623.                         (power (sub 1 'ell)
  624.                            (sub (add (inv 2)
  625.                                  (mul 2 a)
  626.                                  (* 2 x))
  627.                             (add c y)))
  628.                         fun)
  629.                        'ell x))
  630.                 'ell (- x y)))
  631.            'ell y)))
  632.  
  633. (defun f88 (x y a c fun )
  634.        (mul
  635.     (inv (mul (factf c y)
  636.           (factf (sub (add c y) (add a x)) (- x y))
  637.           (factf (add a (inv 2) x)
  638.              (sub b (sub x (sub a (inv 2)))))))
  639.     (power 'ell (sub 1 c))
  640.     (power (sub 1 'ell)(sub (add y c) (add a (inv 2))))
  641.     ($diff (mul (power 'ell (add a x))
  642.             (power (sub 1 'ell)(mul -1 a))
  643.             ($diff (mul (power 'ell (sub c (sub x (sub (inv 2) (mul a 2))))))
  644.                (power (sub 1 'ell) (sub (add a x b)(sub c y)))
  645.                 ($diff (mul (power 'ell (sub b  1 ))
  646.                         
  647.                         fun)
  648.                        'ell (sub b (sub a (sub (x (inv 2))))))
  649.                 'ell (- x y)))
  650.            'ell y)))
  651.  
  652.  
  653.  
  654. (DEFUN SIMPR2F1
  655.        (L1 L2)
  656.        ((LAMBDA (INL1P INL1BP INL2P)
  657.         (COND (INL2P (COND ((AND INL1P INL1BP)
  658.                     (derivint (- (car l1) 1)
  659.                           (- (cadr l1)
  660.                          (car l1))
  661.                           (- (- (car l2)
  662.                             (cadr l1))
  663.                          1)))
  664.                    (INL1P (GEREDno2 (CADR L1)
  665.                             (CAR L1)
  666.                             (CAR L2)))
  667.                    (INL1BP (GEREDno2 (CAR L1)
  668.                              (CADR L1)
  669.                              (CAR L2)))
  670.                    (T 'FAIL1)))
  671.               (INL1P (COND (INL1BP 'D) (T 'C)))
  672.               ((EQ (CAAAR L1) 'RAT)
  673.                (COND (INL1BP 'C) (T 'D)))
  674.               (T 'FAILG)))
  675.     (MAXIMA-INTEGERP (CAR L1))
  676.     (MAXIMA-INTEGERP (CADR L1))
  677.     (MAXIMA-INTEGERP (CAR L2))))
  678. (DEFUN GEREDno1
  679.        (L1 L2)
  680.        (COND ((AND (GREATERP (CAR L2)(CAR L1))
  681.            (GREATERP (CAR L2)(CADR L1)))
  682.           (GEREDF (CAR L1)(CADR L1)(CAR L2)))
  683.          (T (GERED1 L1 L2 'HGFSIMP))))
  684. (DEFUN GEREDno2
  685.        (A B C)
  686.        (COND ((GREATERP C B)(GEREDF B A C))(T (GERED2 A B C))))
  687. (defun derivint
  688.        (n m l)(subst var 'psey
  689.        (mul (power -1 m)
  690.         (factorial (+ n m l 1))
  691.         (inv (factorial n))
  692.         (inv (factorial l))
  693.         (inv (factorial (+ n m)))
  694.         (inv (factorial (+ m l)))
  695.         ($diff  (mul (power (sub 1 'psey) (+ m l))
  696.              ($diff (mul (power  'psey  -1)
  697.                      -1
  698.                      ($log (sub 1 'psey)))
  699.                 'psey
  700.                 l))
  701.             'psey
  702.             (+ n m)))))
  703.  
  704.  
  705.  
  706. (defun hyp-cos
  707.        (a b c)
  708.        (prog (a2 a1 z1)
  709.          (setq a1 (div (sub (add a b) (div 1 2)) 2))
  710.          (setq z1 (sub 1 var))
  711.          (setq a2 (mul c (inv 2)))
  712.          (cond ((equal (sub (add a b) (div 1 2)) c)
  713.             (return (mul (power 2 (sub (mul a1 2) 1))
  714.                  (inv (power  z1 (div 1 2)))
  715.                  (power (add 1
  716.                          (power z1
  717.                             (div 1
  718.                              2)))
  719.                     (sub 1 (mul 2 a1)))))))
  720.          (cond ((equal (add 1 (mul 2 a1)) c)
  721.             (return (mul (power 2 (sub c 1))
  722.                  (power (add 1
  723.                          (power z1
  724.                             (div 1
  725.                              2)))
  726.                     (mul -1 (sub c 1)))))))
  727.          ))
  728.  
  729. (DEFUN DEGEN2F1
  730.        (A B C)
  731.        (COND ((EQ (QUEST (SUB C B)) '$NEGATIVE)
  732.           (COND ((EQ (QUEST (SUB C A)) '$NEGATIVE)
  733.              (GERED1 (LIST A B)(LIST C) 'HGFSIMP))
  734.             (T (GERED2 A B C))))
  735.          ((EQ (QUEST (SUB C A)) '$NEGATIVE)(GERED2 B A C))
  736.          (T (REST-DEGEN A B C))))
  737.  
  738.  
  739. (DEFUN REST-DEGEN
  740.        (A B C)
  741.        (PROG(M N L)
  742.         (COND ((NNI (SETQ M (SUB A 1)))
  743.            (RETURN (REST-DEGEN-1 A B C M))))
  744.         (COND ((NI B)(RETURN (REST-DEGEN-2 A B C))))
  745.         (COND ((AND (NNI (SETQ N (SUB C 1)))
  746.             (NNI (SETQ M (SUB (SUB A N) 1)))
  747.             (NNI (SETQ L (SUB B A)))
  748.             (EQ (SUB (SUB C A) B)
  749.                 (MUL -1 (ADD M M N L 1))))
  750.            (RETURN (GERED1 (LIST A B)
  751.                    (LIST C)
  752.                    'HGFSIMP))))
  753.         (RETURN (hyp-DEG B A C))))
  754.  
  755.  
  756. (DEFUN REST-DEGEN-1
  757.        (A B C M)
  758.        (PROG(N L)
  759.         (COND ((AND (NI B)
  760.             (NI (SUB (SUB C A) B))
  761.             (NNI (SUB (SUB C A) 1)))
  762.            (RETURN (DEG299 A B C))))
  763.         (COND ((AND (NNI (SETQ N (SUB (SUB C M) 2)))
  764.             (NNI (SETQ L (SUB B C)))
  765.             (EQUAL (SUB (SUB C A) B)
  766.                    (MUL -1 (ADD L M 1))))
  767.            (RETURN (GERED1 (LIST A B)
  768.                    (LIST C)
  769.                    'HGFSIMP))))
  770.         (COND ((NNI (SETQ L (SUB (SUB B M) 1)))
  771.            (RETURN (REST-DEGEN-1A A B C M L))))
  772.         (RETURN (hyp-DEG B A C))))
  773.  
  774.  
  775. (DEFUN REST-DEGEN-1A
  776.        (A B C M L)
  777.        (PROG(N)
  778.         (COND ((AND (NNI (SETQ N
  779.                    (SUB (SUB (SUB C M) L) 2)))
  780.             (EQUAL (SUB N M)(SUB (SUB C A) B)))
  781.            (RETURN (DEG2913 A B C))))
  782.         (COND ((AND (EQUAL C (MUL -1 N))
  783.             (EQUAL (SUB (SUB C A) B)
  784.                    (MUL -1 (ADD M M L N 2))))
  785.            (RETURN (DEG2918 A B C))))
  786.         (RETURN (hyp-DEG B A C))))
  787.  
  788.  
  789. (DEFUN REST-DEGEN-2
  790.        (A B C)
  791.        (PROG(M L)
  792.         (COND ((AND (NI C)(NI (SUB (SUB C A) B)))
  793.            (RETURN (REST-DEGEN-2A A B C))))
  794.         (COND ((AND (NNI (SETQ M (SUB C 1)))
  795.             (NNI (SETQ L (SUB A C)))
  796.             (NI (SUB (SUB C A) B)))
  797.            (RETURN (DEG292 A B C))))
  798.         (RETURN (hyp-DEG B A C))))
  799.  
  800.  
  801. (DEFUN REST-DEGEN-2A
  802.        (A B C)
  803.        (PROG()
  804.         (COND ((NNI (SUB A C))
  805.            (RETURN (GERED1 (LIST A B)
  806.                    (LIST C)
  807.                    'HGFSIMP))))
  808.         (COND ((NNI (SUB (SUB C A) 1))
  809.            (RETURN (DEG2917 A B C))))
  810.         (RETURN (hyp-DEG B A C))))
  811.  
  812. (DEFUN QUEST
  813.        (A)
  814.        (COND ((NUMBERP A)(CHECKSIGNTM A))
  815.          ((EQUAL (CAaR A) 'RAT)(CHECKSIGNTM A))
  816.          (T NIL)))
  817.  
  818.  
  819.  
  820. (DEFUN NNI(A)(COND ((MAXIMA-INTEGERP A)(NOT (MINUSP A)))))
  821.  
  822.  
  823. (DEFUN NI(A)(NOT (MAXIMA-INTEGERP A)))
  824.  
  825.  
  826. (DEFUN hyp-DEG
  827.        (A B C)
  828.        (PROG()
  829.         (COND (FLDEG (SETQ FLDEG NIL)
  830.              (RETURN (HGFSIMP (LIST A B)
  831.                       (LIST C)
  832.                       VAR))))
  833.         (SETQ FLDEG T)
  834.         (RETURN (FPQFORM (LIST A B)(LIST C) VAR))))
  835.  
  836.  
  837. (DEFUN DEG2913
  838.        (A B C)
  839.        (MUL (POWER (MUL -1 VAR)(MUL -1 B))
  840.         (HGFSIMP (LIST (ADD B 1 (MUL -1 C)) B)
  841.              (LIST (ADD B 1 (MUL -1 A)))
  842.              (INV VAR))))
  843.  
  844.  
  845. (DEFUN DEG2918
  846.        (A B C)
  847.        (MUL (POWER VAR (SUB 1 C))
  848.         (POWER (SUB 1 VAR)(ADD C (MUL -1 A)(MUL -1 B)))
  849.         (HGFSIMP (LIST (SUB 1 A)(SUB 1 B))
  850.              (LIST (SUB 2 C))
  851.              VAR)))
  852.  
  853.  
  854. (DEFUN DEG2917
  855.        (A B C)
  856.        (MUL (POWER VAR (SUB 1 C))
  857.         (HGFSIMP (LIST (ADD A 1 (MUL -1 C))
  858.                (ADD B 1 (MUL -1 C)))
  859.              (LIST (SUB 2 C))
  860.              VAR)))
  861.  
  862.  
  863. (DEFUN DEG299
  864.        (A B C)
  865.        (MUL (POWER (MUL -1 VAR)(MUL -1 A))
  866.         (HGFSIMP (LIST A (ADD A 1 (MUL -1 C)))
  867.              (LIST (ADD A 1 (MUL -1 B)))
  868.              (INV VAR))))
  869.  
  870.  
  871. (DEFUN LEGFUN                      
  872.        (A B C)               
  873.        (PROG(1-C A-B C-A-B INV2)
  874.         (SETQ 1-C
  875.           (SUB 1 C)
  876.           A-B
  877.           (SUB A B)
  878.           C-A-B
  879.           (SUB (SUB C A) B)
  880.           INV2
  881.           (INV 2))
  882.         (COND ((EQUAL A-B INV2)   
  883.            (RETURN (GERED1 (LIST A B)(LIST C) 'LEGF24))))
  884.         (COND ((EQUAL A-B (MUL -1 INV2))
  885.            (RETURN (LEGF24 (LIST A B)(LIST C) VAR))))
  886.         (COND ((EQUAL C-A-B INV2)
  887.            (RETURN (LEGF20 (LIST A B)(LIST C) VAR))))
  888.         (COND ((EQUAL C-A-B (MUL -1 INV2))
  889.            (RETURN (GERED1 (LIST A B)(LIST C) 'LEGF20))))
  890.         (COND ((EQUAL 1-C A-B)
  891.            (RETURN (LEGF16 (LIST A B)(LIST C) VAR))))
  892.         (COND ((EQUAL 1-C (MUL -1 A-B))
  893.            (RETURN (GERED1 (LIST A B)(LIST C) 'LEGF16))))
  894.         (COND ((EQUAL 1-C C-A-B)
  895.            (RETURN (GERED1 (LIST A B)(LIST C) 'LEGF14))))
  896.         (COND ((EQUAL 1-C (MUL -1 C-A-B))
  897.            (RETURN (LEGF14 (LIST A B)(LIST C) VAR))))
  898.         (COND ((EQUAL A-B (MUL -1 C-A-B))
  899.            (RETURN (LEGF36 (LIST A B)(LIST C) VAR))))
  900.         (COND ((OR (EQUAL 1-C INV2)
  901.                (EQUAL 1-C (MUL -1 INV2)))
  902.            (RETURN (LEGPOL A B C))))
  903.         (COND ((EQUAL A-B C-A-B)
  904.            (RETURN 'LEGENDRE-FUNCT-TO-BE-DISCOVERED)))
  905.         (RETURN NIL)))
  906.  
  907.  
  908.  
  909. (DEFUN LEGF20
  910.        (L1 L2 VAR)
  911.        (PROG(M N B C)
  912.         (SETQ B (CADR L1) C (CAR L2))
  913.         (SETQ M (SUB 1 C) N (MUL -1 (ADD B B M)))
  914.         (RETURN (MUL (LF N M)
  915.              (LEGEN N
  916.                 M
  917.                 (POWER (SUB 1 VAR) (INV 2))
  918.                 '$P)))))
  919.  
  920.  
  921. (DEFUN LEGF24
  922.        (L1 L2 VAR)
  923.        (PROG(M N A C)
  924.         (SETQ A
  925.           (CAR L1)
  926.           C
  927.           (CAR L2)
  928.           M
  929.           (SUB 1 C)
  930.           N
  931.           (MUL -1 (ADD A A M)))
  932.         (RETURN (MUL (LF N M)
  933.              (POWER VAR (ADD N M))
  934.              (LEGEN N
  935.                 M
  936.                 (INV (POWER (SUB 1 VAR)
  937.                         (INV 2)))
  938.                 '$P)))))
  939.  
  940.  
  941. (DEFUN LEGF16
  942.        (L1 L2 VAR)
  943.        (PROG(M N A C)
  944.         (SETQ A (CAR L1) C (CAR L2) M (SUB 1 C) N (MUL -1 A))
  945.         (RETURN (MUL (POWER 2 (MUL -1 N))
  946.              (POWER (SUB VAR 1)(DIV M -2))
  947.              (INV (GM (SUB 1 M)))
  948.              (POWER (ADD VAR 1)(ADD (DIV M 2) N))
  949.              (LEGEN N
  950.                 M
  951.                 (DIV (ADD 1 VAR)(SUB 1 VAR))
  952.                 '$P)))))
  953.  
  954.  
  955. (DEFUN LF
  956.        (N M)
  957.        (MUL (POWER 2 M)
  958.         (INV (POWER (SUB (POWER VAR 2) 1)(DIV M 2)))
  959.         (INV (GM (SUB 1 M)))))
  960.  
  961.  
  962. (DEFUN LEGF14
  963.        (L1 L2 VAR)
  964.        (PROG(M N A C b)
  965.         (SETQ l (s+c (car l1))
  966.           a (cond ((eq (cdras 'c l) 0) (cdras 'f l))
  967.               (t (mul -1 (cdras 'f l))))
  968.           C (CAR L2) M (SUB 1 C)
  969.           N (mul -1 a))
  970.         (RETURN (MUL (POWER  (ADD VAR 1)(DIV M 2))
  971.              (POWER (SUB VAR 1)(DIV M -2))
  972.              (INV (GM (SUB 1 M)))
  973.              (LEGEN N M (SUB 1 (MUL 2 VAR)) '$P)))))
  974.  
  975.  
  976. (DEFUN LEGF36
  977.        (L1 L2 VAR)
  978.        (PROG(N M A B)
  979.         (SETQ A (CAR L1) B (CADR L1) N (SUB B 1) M (SUB B A))
  980.         (RETURN (MUL (POWER 2 N)
  981.              (GM (ADD 1 N))
  982.              (GM (ADD 1 N M))
  983.              (POWER (ADD VAR 1)
  984.                 (ADD (DIV M 2)(MUL -1 N) -1))
  985.              (POWER (SUB VAR 1)(DIV M -2))
  986.              (INV (GM (ADD 2 N N)))
  987.              (POWER '$%E (MUL -1 '$%I M '$%PI))
  988.              (LEGEN N M (DIV (SUB 2 VAR) VAR) '$Q)))))
  989.  
  990.  
  991. (DEFUN LEGEN
  992.        (N M X PQ)
  993.        (LIST '(MQAPPLY)
  994.          (LIST (COND ((EQ PQ '$Q) '($%Q ARRAY))
  995.              (T '($%P ARRAY)))
  996.            N
  997.            M)
  998.          X))
  999.  
  1000.  
  1001. (DEFUN LEGPOL
  1002.        (A B C)
  1003.        (PROG(L V)
  1004.         (COND ((NOT (hyp-NEGP-IN-L (LIST A)))
  1005.            (RETURN 'FAIL-1-IN-C-1-CASE)))
  1006.         (SETQ L (VFVP (DIV (ADD B A) 2)))
  1007.         (SETQ V (CDR (ZL-ASSOC 'V L)))
  1008.         (COND ((AND (EQUAL V '((RAT SIMP) 1 2))(EQUAL C 1))
  1009.            (RETURN (LEGENPOL (MUL -1 A)
  1010.                      (SUB 1 (MUL 2 VAR))))))
  1011.         (COND ((AND (EQUAL C '((RAT SIMP) 1 2))
  1012.             (EQUAL (SUB B A) '((RAT SIMP) 1 2)))
  1013.            (RETURN (MUL (FACTORIAL (MUL -1 A))
  1014.                 (POWER 2 A)
  1015.                 (MULTAUG (INV 2) (MUL -1 A))
  1016.                 (LEGENPOL (MUL -1 A)
  1017.                       (POWER
  1018.                        VAR
  1019.                        (DIV -1 2)))))))
  1020.         (return nil)))
  1021.  
  1022.  
  1023.        
  1024. (DEFUN MULTAUG
  1025.        (A N)
  1026.        (COND ((ZEROP N) 1)(T (MUL A (MULTAUG (ADD A 1)(SUB1 N))))))
  1027.  
  1028.  
  1029. (DEFUN GERED1
  1030.        (L1 L2 SIMPFLG)
  1031.        (MUL (POWER (SUB 1 VAR)
  1032.            (ADD (CAR L2)
  1033.             (MUL -1 (CAR L1))
  1034.             (MUL -1 (CADR L1))))
  1035.         (funcall SIMPFLG
  1036.              (LIST (SUB (CAR L2) (CAR L1))
  1037.                (SUB (CAR L2) (CADR L1)))
  1038.              L2
  1039.              VAR)))
  1040.  
  1041.  
  1042.  
  1043.  
  1044.  
  1045. (DEFUN GERED2
  1046.        (A B C)
  1047.        (MUL (POWER (SUB 1 VAR)(MUL -1 A))
  1048.         (HGFSIMP (LIST A (SUB C B))
  1049.              (LIST C)
  1050.              (DIV VAR (SUB VAR 1)))))
  1051.  
  1052.  
  1053. (DEFUN GEREDF
  1054.        (A B C)
  1055.        (ADD (DIV (MUL (GM C)
  1056.               (GM (ADD C (MUL -1 A)(MUL -1 B)))
  1057.               (POWER VAR (MUL -1 A))
  1058.               (HGFSIMP (LIST A (ADD A 1 (MUL -1 C)))
  1059.                    (LIST (ADD A B (MUL -1 C) 1))
  1060.                    (SUB 1 (DIV 1 VAR))))
  1061.          (MUL (GM (SUB C A))(GM (SUB C B))))
  1062.         (DIV (MUL (GM C)
  1063.               (GM (ADD A B (MUL -1 C)))
  1064.               (POWER (SUB 1 VAR)
  1065.                  (ADD C (MUL -1 A)(MUL -1 B)))
  1066.               (POWER VAR (SUB A C))
  1067.               (HGFSIMP (LIST (SUB C A)(SUB 1 A))
  1068.                    (LIST (ADD C
  1069.                       (MUL -1 A)
  1070.                       (MUL -1 B)
  1071.                       1))
  1072.                    (SUB 1 (DIV 1 VAR))))
  1073.          (MUL (GM A)(GM B)))))
  1074.  
  1075.  
  1076.  
  1077. (DEFUN TRIG-LOG
  1078.        (L1 L2)
  1079.        (COND ((EQUAL (SIMPLIFYA (CAR L2) NIL) '((RAT SIMP) 3 2))
  1080.           (TRIG-LOG-3 L1 L2))
  1081.          ((EQUAL (SIMPLIFYA (CAR L2) NIL) '((RAT SIMP) 1 2))
  1082.           (TRIG-LOG-1 L1 L2))
  1083.          (T nil)))
  1084.  
  1085.  
  1086. (DEFUN TRIG-LOG-3
  1087.        (L1 L2)
  1088.        (COND ((AND (OR (equal (car l1) 1) (equal (cadr l1) 1))
  1089.            (OR (equal (car l1) (div 1 2))
  1090.                (equal (cadr l1) (div 1 2))))
  1091.           (TRIG-LOG-3-EXEC L1 L2))
  1092.          ((and (equal (car l1) (cadr l1))
  1093.            (or (equal 1 (car l1))
  1094.                (equal (div 1 2) (car l1))))
  1095.           (trig-log-3a-exec l1 l2))
  1096.          ((or(equal (add (car l1) (cadr l1)) 1)
  1097.          (equal (add (car l1) (cadr l1)) 2))
  1098.           (trig-sin l1 l2))
  1099.          ((or (equal (sub (car l1) (cadr l1)) (div 1 2))
  1100.           (equal (sub (cadr l1) (car l1)) (div 1 2)))
  1101.           (trig-3 l1 l2))
  1102.          (T nil)))
  1103.  
  1104. (defun trig-3
  1105.        (l1 l2)
  1106.        (prog (a z)
  1107.          (return (mul (inv (setq z (power var (div 1 2))))
  1108.               (inv 2)
  1109.               (inv (setq a
  1110.                      (sub 1
  1111.                       (sub (add (car l1)
  1112.                             (cadr l1))
  1113.                            (div 1 2)))))
  1114.               (sub (power (add 1 z) a)
  1115.                    (power (sub 1 z) a))))))
  1116. (defun trig-sin
  1117.        (l1 l2)
  1118.        (prog (a1 z1 a b c)
  1119.          (setq a (car l1) b (cadr l1) c (car l2))
  1120.          (cond ((equal (add a b) 1)
  1121.             (return (mul (inv (mul (mul -1 (sub a b))
  1122.                        ($sin ($asin ($sqrt var)))))
  1123.                  ($sin (mul (mul -1
  1124.                          (sub a b))
  1125.                         ($asin ($sqrt var)))))))
  1126.            ((eq (add a b) 2)
  1127.             (return (mul ($sin (mul (setq z1
  1128.                           ($asin ($sqrt
  1129.                               var)))
  1130.                         (setq a1
  1131.                           (mul -1
  1132.                                (sub a
  1133.                                 b)))))
  1134.                  (inv (mul a1
  1135.                        ($sin z1)
  1136.                        ($cos z1)))))))
  1137.          (return nil)))
  1138.  
  1139. ;Generates atan if arg positive else log
  1140. (defun trig-log-3-exec
  1141.        (l1 l2)
  1142.        (prog (z)
  1143.          (cond ((equal (checksigntm var) '$positive)
  1144.             (return (mul (power (setq z
  1145.                           (power var
  1146.                              (div 1
  1147.                               2)))
  1148.                     -1)
  1149.                  (inv 2)
  1150.                  ($log (div (add 1 z)
  1151.                         (sub 1 z))))))
  1152.            ((equal (checksigntm var) '$negative)
  1153.             (return (mul (power (setq z
  1154.                           (power (mul -1
  1155.                               var)
  1156.                              (div 1
  1157.                               2)))
  1158.                     -1)
  1159.                  ($atan z)))))))
  1160.  
  1161. (defun trig-log-1
  1162.        (l1 l2)
  1163.        (prog (a b c z1 $exponentialize)
  1164.          
  1165.          (setq a (car l1) b (cadr l1) c (car l2))
  1166.          (cond ((equal (add a b) 0)
  1167.             (cond ((equal (checksigntm var) '$positive)
  1168.                (return ($cos (mul (mul 2 a)
  1169.                           ($asin (power var
  1170.                                 (inv 2)))))))
  1171.               (t (return (div (add (power (add (setq
  1172.                                 z1
  1173.                                 (power
  1174.                                  (add
  1175.                                   (mul
  1176.                                    var
  1177.                                    -1)
  1178.                                   1)
  1179.                                  (inv 2)))
  1180.                                var)
  1181.                               (mul 2 a))
  1182.                            (power (sub z1 var)
  1183.                               (mul 2 a)))
  1184.                       2)))
  1185.               ((equal (add a b) 1)
  1186.                (return (mul (inv ($cos (setq z1
  1187.                              ($asin
  1188.                               ($sqrt
  1189.                                var)))))
  1190.                     ($cos (mul z1 (sub a b))))))
  1191.               ((or (equal (sub a b) (inv 2))
  1192.                    (equal (sub a b) (inv -2)))
  1193.                (return (add (div (power (add 1
  1194.                              (setq
  1195.                               z1
  1196.                               (power
  1197.                                var
  1198.                                (inv
  1199.                                 2))))
  1200.                             (mul -2 a))
  1201.                          2)
  1202.                     (div (power (sub 1 z1)
  1203.                             (mul -2 a))
  1204.                          2)))))))
  1205.          
  1206.          (return nil)))
  1207.  
  1208.  
  1209.  
  1210. (DEFUN TRIG-LOG-1 (A B)            ;; 2F1's with C = 1/2
  1211.   (LET (X Z $EXPONENTIALIZE)        ;; 15.1.17, 11, 18, 12, 9, and 19
  1212.        (setq a (car l1) b (cadr l1))
  1213.        (COND ((=0 (M+T A B))
  1214.           (COND ((EQUAL (CHECKSIGNTM VAR) '$POSITIVE)
  1215.              (MCOS (M*T 2. A (MASIN (MSQRT VAR)))))
  1216.             ((EQUAL (CHECKSIGNTM VAR) '$NEGATIVE)
  1217.              (M*T 1//2
  1218.               (M+T (M^T (M+T (SETQ X (MSQRT (M-T 1. VAR)))
  1219.                      (SETQ Z (MSQRT (M-T VAR))))
  1220.                     (SETQ B (M*T 2. B)))
  1221.                    (M^T (M-T X Z) B))))
  1222.             (T ())))
  1223.          ((EQUAL (M+T A B) 1.)
  1224.           (COND ((EQUAL (CHECKSIGNTM VAR) '$POSITIVE)
  1225.              (M//T (MCOS (M*T (M-T A B) (SETQ Z (MASIN (MSQRT VAR)))))
  1226.                (MCOS Z)))
  1227.             ((EQUAL (CHECKSIGNTM VAR) '$NEGATIVE)
  1228.              (M*T 1//2 (M//T (SETQ X (MSQRT (M-T 1. VAR))))
  1229.               (M+T (M^T (M+T X (SETQ Z (MSQRT (M-T VAR))))
  1230.                     (SETQ B (M-T A B)))
  1231.                    (M^T (M-T X Z) B))))
  1232.             (T ())))
  1233.          ((=1//2 (HYP-MABS (M-T B A)))
  1234.           (COND ((EQUAL (CHECKSIGNTM VAR) '$POSITIVE)
  1235.              (M*T 1//2
  1236.               (M+T (M^T (M1+T (SETQ Z (MSQRT VAR)))
  1237.                     (SETQ B (M-T 1//2 (M+T A B))))
  1238.                    (M^T (M-T 1. Z) B))))
  1239.             ((EQUAL (CHECKSIGNTM VAR) '$NEGATIVE)
  1240.              (M*T (M^T (MCOS (SETQ Z (MATAN (MSQRT (M-T VAR)))))
  1241.                    (SETQ B (M+T A B -1//2)))
  1242.               (MCOS (M*T B Z))))
  1243.             (T ())))
  1244.          (T ()))))
  1245.  
  1246.  
  1247. ; List L contains two elements first the numerator parameter that
  1248. ;exceeds the denumerator one and is called "C", second
  1249. ;the difference of the two parameters which is called "M". 
  1250.  
  1251. (DEFUN DIFFINTPROP-GEN-EXEC (L L1 L2) 
  1252.        (PROG (C M POLY CONSTFACT ) 
  1253.          (SETQ C (CAR L) 
  1254.            M (CADR L) 
  1255.            L1 (ZL-DELETE C L1 1.) 
  1256.            C (SUB C M)
  1257.            L2 (ZL-DELETE C L2 1.) 
  1258.            POLY ($EXPAND (CONSTRPOLY C M 'AVGOUSTIS)) 
  1259.            CONSTFACT (CREATECONSTFACT C M))
  1260.          (RETURN (YANMULT CONSTFACT
  1261.                   (DIFFINTPROP-EXEC POLY L1 L2))))) 
  1262.  
  1263. (DEFUN CONSTRPOLY (C M K) 
  1264.        (COND ((ZEROP M) 1.)
  1265.          (T (MUL (ADD C K (SUB1 M)) (CONSTRPOLY C (SUB1 M) K))))) 
  1266.  
  1267. (DEFUN CREATECONSTFACT (C M) 
  1268.        (COND ((ZEROP M) 1.)
  1269.          (T (MUL (INV (ADD C (SUB1 M)))
  1270.              (CREATECONSTFACT C (SUB1 M)))))) 
  1271.  
  1272. (DEFUN DIFFINTPROP-EXEC (POLY L1 L2) 
  1273.        (DISTRDIFFINTPROP (CREATECOEFPOWLIST-EXEC POLY) L1 L2)) 
  1274.  
  1275. (DEFUN DISTRDIFFINTPROP (L L1 L2) 
  1276.        (COND ((NULL L) 0.)
  1277.          (T (ADD (YANMULT ($FACTOR (CADAR L))
  1278.                   (DIFFINTPROP (CAAR L) L1 L2))
  1279.              (DISTRDIFFINTPROP (CDR L) L1 L2))))) 
  1280.  
  1281. (DEFUN DIFFINTPROP (POW L1 L2) 
  1282.        (COND ((ZEROP POW) (HGFSIMP L1 L2 VAR))
  1283.          ((EQUAL POW 1.)
  1284.           (YANMULT (MUL (DIV (MULTPL L1) (MULTPL L2)) VAR)
  1285.                (HGFSIMP (INCR1 L1) (INCR1 L2) VAR)))
  1286.          (T (SEARCHADDSERIESLIST POW L1 L2)))) 
  1287.  
  1288. (DEFUN SEARCHADDSERIESLIST (POW L1 L2) 
  1289.        (PROG (SERIES RES) 
  1290.          (COND ((SETQ SERIES (SEARCHSERIESLISTP SERIESLIST POW))
  1291.             (RETURN (EVAL SERIES))))
  1292.          (SETQ 
  1293.           SERIESLIST
  1294.           (APPEND
  1295.            SERIESLIST
  1296.            (LIST
  1297.         (LIST
  1298.          POW
  1299.          (SETQ RES
  1300.                '(YANMULT (MUL (DIV (MULTPL L1) (MULTPL L2))
  1301.                       VAR)
  1302.                  (DIFFINTPROPRECURSE (SUB1 POW)
  1303.                              (INCR1 L1)
  1304.                              (INCR1 L2))))))))
  1305.          (RETURN (EVAL RES)))) 
  1306.  
  1307. (DEFUN DIFFINTPROPRECURSE (POW L1 L2) 
  1308.        (PROG (POLY) 
  1309.          (SETQ POLY
  1310.            ($EXPAND (POWER (ADD 'AVGOUSTIS 1.) POW)))
  1311.          (RETURN (DIFFINTPROP-EXEC POLY L1 L2)))) 
  1312.  
  1313. (DEFUN MULTPL (L) 
  1314.        (COND ((NULL L) 1.) (T (MUL (CAR L) (MULTPL (CDR L)))))) 
  1315.  
  1316. (DEFUN CREATECOEFPOWLIST-EXEC (POLY) 
  1317.        (PROG (HP CONSTER) 
  1318.          (SETQ CONSTER (CONSTERMINIT POLY 'AVGOUSTIS) 
  1319.            HP ($HIPOW POLY 'AVGOUSTIS))
  1320.          (RETURN (APPEND (LIST (LIST 0. CONSTER))
  1321.                  (CREATECOEFPOWLIST POLY HP))))) 
  1322.  
  1323. (DEFUN CREATECOEFPOWLIST (POLY HP) 
  1324.        (COND ((EQUAL HP 1.)
  1325.           (LIST (LIST 1. ($COEFF POLY 'AVGOUSTIS))))
  1326.          (T (APPEND (CREATECOEFPOWLIST POLY (SUB1 HP))
  1327.             (LIST (LIST HP
  1328.                     ($COEFF POLY
  1329.                         (POWER 'AVGOUSTIS
  1330.                            HP)))))))) 
  1331.  
  1332. (DEFUN CONSTERMINIT (FUN VAR) 
  1333.        (COND ((EQ (CAAR FUN) 'MPLUS) (CONSTERM (CDR FUN) VAR))
  1334.          (T (COND ((FREEVAR FUN) FUN) (T 0.))))) 
  1335.  
  1336. (DEFUN SEARCHSERIESLISTP (SERIESLIST POW) 
  1337.        (COND ((NULL SERIESLIST) NIL)
  1338.          ((EQUAL (CAAR SERIESLIST) POW) (CADAR SERIESLIST))
  1339.          (T (SEARCHSERIESLISTP (CDR SERIESLIST) POW)))) 
  1340.  
  1341. (DEFUN YANMULT (A B) 
  1342.        (COND ((EQ (CAAR B) 'MPLUS) (YANMUL A (CDR B)))
  1343.          (T (MUL A B)))) 
  1344.  
  1345. (DEFUN YANMUL (A B) 
  1346.        (COND ((NULL B) 0.)
  1347.          (T (ADD (MUL A (CAR B)) (YANMUL A (CDR B)))))) 
  1348.  
  1349.  
  1350. (DEFUN FREEVARPAR(EXP)(COND ((FREEVAR EXP)(FREEPAR EXP))(T NIL)))
  1351.  
  1352. (DECLARE-top (SPECIAL serieslist VAR PAR ZEROSIGNTEST PRODUCTCASE))
  1353. (setq par '$P)
  1354. (DEFUN FREEVAR (A) 
  1355.        (COND ((ATOM A) (NOT (EQ A VAR)))
  1356.          ((ALIKE1 A VAR)NIL)
  1357.          ((AND (NOT (ATOM (CAR A)))
  1358.            (MEMQ 'ARRAY (CDAR A)))
  1359.           (COND ((FREEVAR (CDR A)) T)
  1360.             (T (PRINC 'VARIABLE-OF-INTEGRATION-APPEARED-IN-SUBSCRIPT)
  1361.                (ERR))))
  1362.          (T (AND (FREEVAR (CAR A)) (FREEVAR (CDR A))))))
  1363.  
  1364. (DEFUN FREEPAR
  1365.        (EXP)
  1366.        (COND ((ATOM EXP)(NOT (EQ EXP PAR)))
  1367.          (T (AND (FREEPAR (CAR EXP))(FREEPAR (CDR EXP))))))
  1368.  
  1369. (DEFUN HASPAR(EXP)(COND ((FREEPAR EXP) NIL)(T T)))
  1370.  
  1371. (DEFUN CONFL
  1372.        (L1 L2 VAR)
  1373.        (PROG(A C A-C K M z)
  1374.         (SETQ A (CAR L1) C (CAR L2))
  1375.         (COND ((EQUAL C (ADD A A))
  1376.  
  1377.            (RETURN (MUL (POWER '$%E (setq z (DIV VAR 2)))
  1378.                 (bestrig (add a (inv 2))
  1379.                      (div (mul z z) 4))))))
  1380.                      
  1381.         
  1382.         (COND ((NOT (MAXIMA-INTEGERP (SETQ A-C (SUB A C))))
  1383.            (GO KUMCHECK)))
  1384.         (COND ((MINUSP A-C)(RETURN (ERFGAMMARED A C VAR))))
  1385.         (RETURN (KUMMER L1 L2))
  1386.         KUMCHECK
  1387.         (COND ((MAXIMA-INTEGERP A)(RETURN (KUMMER L1 L2))))
  1388.         (SETQ M
  1389.           (DIV (SUB C 1) 2)
  1390.           K
  1391.           (ADD (INV 2) M (MUL -1 A)))
  1392.         (RETURN (MUL (POWER VAR (MUL -1 (ADD (INV 2) M)))
  1393.              (POWER '$%E (DIV VAR 2))
  1394.              (WHITFUN K M VAR)))))
  1395. (DEFUN HYPREDERF
  1396.        (X)
  1397.        (PROG()
  1398.         (SETQ X (MUL '$%I (POWER X (INV 2))))
  1399.         (RETURN (MUL (POWER '$%PI (INV 2))
  1400.              (INV 2)
  1401.              (INV X)
  1402.              (LIST '(%ERF) X)))))
  1403. (DEFUN ERFGAMMARED
  1404.        (A C Z)
  1405.        (COND ((AND (NUMP A)(NUMP C))(ERFGAMNUMRED A C Z))
  1406.          (T (GAMMAREDS A C Z))))
  1407. (DEFUN GAMMAREDS
  1408.        (A C Z)
  1409.        (PROG(M NUMPROD RESULT COUNT ATEMP)
  1410.         (SETQ M (SUB C A))
  1411.         (COND ((EQ M 1)(RETURN (HYPREDINCGM A Z))))
  1412.         (SETQ NUMPROD
  1413.           (PROD A M)
  1414.           COUNT
  1415.           2
  1416.           ATEMP
  1417.           A
  1418.           RESULT
  1419.           (SUB (MUL 2
  1420.                 NUMPROD
  1421.                 (INV ATEMP)
  1422.                 (HYPREDINCGM ATEMP Z))
  1423.                (MUL 2
  1424.                 NUMPROD
  1425.                 (INV (SETQ ATEMP (ADD ATEMP 1)))
  1426.                 (HYPREDINCGM ATEMP Z))))
  1427.         LOOP
  1428.         (COND ((EQ COUNT M)(RETURN RESULT)))
  1429.         (SETQ COUNT
  1430.           (ADD1 COUNT)
  1431.           ATEMP
  1432.           (ADD ATEMP 1)
  1433.           RESULT
  1434.           (ADD RESULT
  1435.                (MUL (POWER -1 COUNT)
  1436.                 (INV (FACTORIAL (SUB M
  1437.                          (SUB1 COUNT))))
  1438.                 NUMPROD
  1439.                 (INV ATEMP)
  1440.                 (HYPREDINCGM ATEMP Z))))
  1441.         (GO LOOP)))
  1442. (DEFUN HYPREDINCGM
  1443.        (A Z)
  1444.        (PROG()
  1445.         (SETQ Z (MUL -1 Z))
  1446.         (RETURN (MUL A
  1447.              (POWER Z (MUL -1 A))
  1448.              (LIST '($%GAMMAGREEK) A Z)))))
  1449. (DEFUN PROD
  1450.        (A M)
  1451.        (COND ((EQ M 2) (MUL A (ADD A 1)))
  1452.          (T (MUL (ADD A (SUB1 M))(PROD A (SUB1 M))))))
  1453. (DEFUN ERFGAMNUMRED
  1454.        (A C Z)
  1455.        (COND ((MAXIMA-INTEGERP (SUB C (INV 2)))(ERFRED A C Z))
  1456.          (T (GAMMAREDS A C Z))))
  1457. (DEFUN ERFRED
  1458.        (A C Z)
  1459.        (PROG(N M)
  1460.         (SETQ N (SUB A (INV 2)) M (SUB C (DIV 3 2)))
  1461.         (COND ((NOT (OR (GREATERP N M)(MINUSP N)))
  1462.            (RETURN (THno33 N M Z))))
  1463.         (COND ((AND (MINUSP N)(MINUSP M))
  1464.            (RETURN (THno35 (MUL -1 N)(MUL -1 M) Z))))
  1465.         (COND ((AND (MINUSP N)(PLUSP M))
  1466.            (RETURN (THno34 (MUL -1 N) M Z))))
  1467.         (RETURN (GAMMAREDS (ADD N (INV 2))
  1468.                    (ADD M (DIV 3 2))
  1469.                    Z))))
  1470. (DEFUN THno33
  1471.        (N M X)
  1472.        ((LAMBDA(M-N)
  1473.            (SUBST X
  1474.               'YANNIS
  1475.               (MUL (DIV (MUL (POWER -1 M-N)
  1476.                      (FCTRL (DIV 3 2) M-N)
  1477.                      (FCTRL (ADD M-N
  1478.                          (DIV 3 2))
  1479.                         N))
  1480.                 (MUL (FCTRL 1 M-N)
  1481.                      (FCTRL (inv 2) N)))
  1482.                (MEVAL (LIST '($DIFF)
  1483.                     (MUL (POWER '$%E
  1484.                             'YANNIS)
  1485.                          (MEVAL (LIST '($DIFF)
  1486.                               (MUL
  1487.                                (POWER
  1488.                                 '$%E
  1489.                                 (MUL
  1490.                                  -1
  1491.                                  'YANNIS))
  1492.                                (HYPREDERF
  1493.                                 'YANNIS))
  1494.                               'YANNIS
  1495.                               M-N)))
  1496.                     'YANNIS
  1497.                     N)))))
  1498.     (SUB M N)))
  1499. (DEFUN THno34
  1500.        (N M X)
  1501.        (SUBST X
  1502.           'YANNIS
  1503.           (MUL (POWER -1 M)
  1504.            (DIV (MUL (FCTRL (DIV 3 2) M)
  1505.                  (POWER '$%E 'YANNIS))
  1506.             (MUL (FCTRL 1 M)
  1507.                  (FCTRL (ADD1 M) N)
  1508.                  (POWER 'YANNIS M)))
  1509.            (MEVAL (LIST '($DIFF)
  1510.                 (MUL (POWER 'YANNIS
  1511.                         (PLUS M N))
  1512.                      (MEVAL (LIST '($DIFF)
  1513.                           (MUL (POWER '$%E
  1514.                                   (MUL
  1515.                                    -1
  1516.                                    'YANNIS))
  1517.                                (HYPREDERF 'YANNIS))
  1518.                           'YANNIS
  1519.                           M)))
  1520.                 'YANNIS
  1521.                 N)))))
  1522. (DEFUN THno35
  1523.        (N M X)
  1524.        (SUBST X
  1525.           'YANNIS
  1526.           (MUL (DIV (POWER 'YANNIS (SUB M (inv 2)))
  1527.             (MUL (POWER -1 (TIMES -1 M))
  1528.                  (FCTRL 1 N)
  1529.                  (FCTRL (INV -2) M)))
  1530.            (MEVAL (LIST '($DIFF)
  1531.                 (MUL (POWER 'YANNIS (inv 2))
  1532.                      (POWER '$%E 'YANNIS)
  1533.                      (MEVAL (LIST '($DIFF)
  1534.                           (MUL (POWER '$%E
  1535.                                   (MUL
  1536.                                    -1
  1537.                                    'YANNIS))
  1538.                                (POWER 'YANNIS
  1539.                                   N)
  1540.                                (HYPREDERF 'YANNIS))
  1541.                           'YANNIS
  1542.                           N)))
  1543.                 'YANNIS
  1544.                 M)))))
  1545. (DEFUN FCTRL
  1546.        (A N)
  1547.        (COND ((ZEROP N) 1)
  1548.          ((one n) a)
  1549.          (T (MUL (ADD A (SUB1 N))(FCTRL A (SUB1 N))))))
  1550.  
  1551. (defun one (x)(equal x 1))
  1552.  
  1553.  
  1554.  
  1555. (DEFUN CHECKSIGNTM            
  1556.        (EXPR)                
  1557.        (PROG (ASLIST QUEST ZEROSIGNTEST PRODUCTCASE)    
  1558.          (SETQ ASLIST CHECKCOEFSIGNLIST)
  1559.          (COND ((ATOM EXPR) (GO LOOP)))
  1560.          (COND ((EQ (CAAR EXPR) 'MTIMES)
  1561.             (SETQ PRODUCTCASE T)))
  1562.          LOOP
  1563.          (COND ((NULL ASLIST)
  1564.             (SETQ CHECKCOEFSIGNLIST
  1565.               (APPEND CHECKCOEFSIGNLIST
  1566.                   (LIST (CONS
  1567.                      EXPR
  1568.                      (LIST
  1569.                       (SETQ
  1570.                        QUEST
  1571.                        (CHECKFLAGANDACT
  1572.                         EXPR)))))))
  1573.             (RETURN QUEST)))
  1574.          (COND ((EQUAL (CAAR ASLIST) EXPR)
  1575.             (RETURN (CADAR ASLIST))))
  1576.          (SETQ ASLIST (CDR ASLIST))
  1577.          (GO LOOP))) 
  1578.  
  1579. (DEFUN CHECKFLAGANDACT
  1580.        (EXPR)
  1581.        (COND (PRODUCTCASE (SETQ PRODUCTCASE NIL)
  1582.               (FINDSIGNOFTHEIRPRODUCT (FINDSIGNOFACTORS
  1583.                            (CDR EXPR))))
  1584.          (T (ASKSIGN ($REALPART EXPR))))) 
  1585.  
  1586. (DEFUN FINDSIGNOFACTORS
  1587.        (LISTOFACTORS)
  1588.        (COND ((NULL LISTOFACTORS) NIL)
  1589.          ((EQ ZEROSIGNTEST '$ZERO) '$ZERO)
  1590.          (T (APPEND (LIST (SETQ ZEROSIGNTEST
  1591.                     (CHECKSIGNTM (CAR
  1592.                           LISTOFACTORS))))
  1593.             (FINDSIGNOFACTORS (CDR LISTOFACTORS)))))) 
  1594.  
  1595. (DEFUN FINDSIGNOFTHEIRPRODUCT
  1596.        (LIST)
  1597.        (PROG (SIGN)
  1598.          (COND ((EQ LIST '$ZERO) (RETURN '$ZERO)))
  1599.          (SETQ SIGN '$POSITIVE)
  1600.          LOOP
  1601.          (COND ((NULL LIST) (RETURN SIGN)))
  1602.          (COND ((EQ (CAR LIST) '$POSITIVE)
  1603.             (SETQ LIST (CDR LIST))
  1604.             (GO LOOP)))
  1605.          (COND ((EQ (CAR LIST) '$NEGATIVE)
  1606.             (SETQ SIGN
  1607.               (CHANGESIGN SIGN)
  1608.               LIST
  1609.               (CDR LIST))
  1610.             (GO LOOP)))
  1611.          (RETURN '$ZERO))) 
  1612.  
  1613. (DEFUN CHANGESIGN
  1614.        (SIGN)
  1615.        (COND ((EQ SIGN '$POSITIVE) '$NEGATIVE) (T '$POSITIVE))) 
  1616.  
  1617.  
  1618. (SETQ PAR '$P)                           
  1619.  
  1620. (DEFUN VFVP(EXP)(M2 EXP '(V FREEVARPAR) NIL))
  1621.  
  1622.  
  1623. (DEFUN D*U
  1624.        (EXP)
  1625.        (M2 EXP
  1626.        '((MTIMES)((COEFFTT)(D FREEPAR))((COEFFTT)(U HASPAR)))
  1627.        NIL))
  1628.  
  1629. (DEFUN FPQFORM
  1630.        (L1 L2 ARG)
  1631.        (LIST '(MQAPPLY)
  1632.          (LIST '($%F ARRAY)(LENGTH L1)(LENGTH L2))
  1633.          (APPEND (LIST '(MLIST)) L1)
  1634.          (APPEND (LIST '(MLIST)) L2)
  1635.          ARG))
  1636.  
  1637.  
  1638.  
  1639. (defun splitpfq
  1640.        (l l1 l2)
  1641.        (prog(result prodnum proden count k a1 b1)
  1642.         (setq result
  1643.           0
  1644.           prodnum
  1645.           1
  1646.           proden
  1647.           1
  1648.           count
  1649.           0
  1650.           k
  1651.           (cadr l)
  1652.           a1
  1653.           (car l)
  1654.           b1
  1655.           (sub a1 k))
  1656.         (setq l1
  1657.           (zl-delete a1 l1 1)
  1658.           l2
  1659.           (zl-delete b1 l2 1)
  1660.           result
  1661.           (hgfsimp l1 l2 var))
  1662.         loop
  1663.         (cond ((eq count k) (return result)))
  1664.         (setq count
  1665.           (add1 count)
  1666.           prodnum
  1667.           (mul prodnum (mull l1))
  1668.           proden
  1669.           (mul proden (mull l2))
  1670.           result
  1671.           (add result
  1672.                (mul (combin k count)
  1673.                 (div prodnum proden)
  1674.                 (power var count)
  1675.                 (hgfsimp (setq l1 (incr1 l1))
  1676.                      (setq l2 (incr1 l2))
  1677.                      var))))
  1678.         (go loop)))
  1679.  
  1680. (defun combin
  1681.        (k count)
  1682.        (div (factorial k)
  1683.         (mul (factorial count)(factorial (sub k count)))))
  1684.  
  1685.  
  1686. ;Algor. II from thesis:minimizes differentiations
  1687. (defun ALGII(a b c)
  1688.        (prog (m n ap con sym m+n)
  1689.          (cond ((not (setq sym (cdras 'f (s+c a))))
  1690.             (setq sym 0)))
  1691.          (setq  con (sub a sym))
  1692.          (setq ap sym)
  1693.          (setq m+n (add a b))
  1694.          (setq m ($entier con))
  1695.          (cond ((minusp m)(add1 m)))
  1696.          (setq ap (add (sub con m) ap))
  1697.          (setq n (add b ap))
  1698.          (cond ((and (minusp (mul n m))(greaterp (abs m) (abs n)))
  1699.             (return (list ap (sub ap n) m+n))))
  1700.          (return  (list ap (add ap m) m+n))))
  1701.                 
  1702.                
  1703.  
  1704.  
  1705.  
  1706. ;Algor. 2F1-RL from thesis:step 4:dispatch on a+m,-a+n,1/2+l cases
  1707. (defun step4
  1708.        (a b c)
  1709.        (prog (aprime m n $ratsimpexponens $ratprint newf)
  1710.          (setq alglist
  1711.            (algii a b c)
  1712.            aprime
  1713.            (cadr alglist)
  1714.            m
  1715.            (caddr alglist)
  1716.            n
  1717.            (sub c (inv 2)))
  1718.          (setq $ratsimpexponens $true $ratprint $false)
  1719.          (setq newf
  1720.            ($ratsimp (subst aprime
  1721.                     'psa
  1722.                     (power (add (inv 2)
  1723.                         (mul (power (sub
  1724.                                  1
  1725.                                  var)
  1726.                                 (inv
  1727.                                  2))
  1728.                              (inv 2)))
  1729.                        (sub 1
  1730.                         (mul 2 'psa))))))
  1731.          (return (subst var 'ell
  1732.                 (algiii (subst 'ell var newf)
  1733.                     m n aprime)))))
  1734.  
  1735. ;Pattern match for s(ymbolic) + c(onstant) in parameter
  1736. (DEFUN s+C
  1737.        (EXP)
  1738.        (M2 EXP
  1739.        '((MPLUS)((COEFFPT)(F nonnump))((COEFFPP)(C $numberp)))
  1740.        NIL))
  1741.  
  1742. (defun nonnump (z)
  1743.        (cond ((not ($numberp z)) t)
  1744.          (t nil)))
  1745.  
  1746. ;Algor. III from thesis:determines which Differ. Formula to use
  1747. (defun algiii (fun m n aprime)
  1748.        (prog (mm nn)
  1749.          (setq mm (abs m) nn (abs n))
  1750.          (cond ((and (nni m) (nni n))
  1751.             (cond ((lessp m n) (return (f81 fun m n aprime)))
  1752.               (t (return (f85 fun mm nn aprime)))))
  1753.            ((and (hyp-negp n) (hyp-negp m))
  1754.             (cond ((greaterp (abs n) (abs m))
  1755.                (return (f86 fun mm nn aprime)))
  1756.               (t (return (f82 fun mm nn aprime)))))
  1757.            ((and (hyp-negp m) (nni n))(return (f83 fun mm nn aprime)))
  1758.            (t (return (f84 fun mm nn aprime))))))
  1759.  
  1760. ;Factorial function:x*(x+1)*(x+2)...(x+n-1)
  1761. (defun factf (x n)
  1762.        (cond ((zerop n) 1)
  1763.          (t (mul x (factf (add x 1) (sub n 1))))))
  1764.  
  1765. ;Formula  #85 from Yannis thesis:finds by differentiating F[2,1](a,b,c,z)
  1766. ; given F[2,1](a+m,b,c+n,z) where b=-a and c=1/2, n,m integers
  1767. (defun f85 (fun m n a)
  1768.        (mul (factf (inv 2) n)
  1769.         (inv (power -1 n))
  1770.         (inv (factf (sub (add a m) n) n))
  1771.         (inv (factf (sub (inv 2) (mul a -1)) n))
  1772.         (inv (factf a (- m n)))
  1773.         (power (sub 1 'ell) (sub (sub (add 1 n) m) a))
  1774.         ($diff (mul
  1775.             (power (sub 1 'ell) (sub (add a m) 1))
  1776.             (power 'ell (sub 1 a))
  1777.             ($diff (mul
  1778.                 (power 'ell (sub (add a m -1) n))
  1779.                 fun) 'ell (- m n))) 'ell n)))
  1780.  
  1781. ;Used to find negative things that are not integers,eg RAT's    
  1782. (defun hyp-negp(x) (cond ((equal (asksign x) '$negative) t)(t nil)))
  1783.  
  1784. (defun f81 (fun m n a)
  1785.        (mul (factf (add (inv 2) (- n m)) m)
  1786.         (factf (inv 2) (- n m))
  1787.         (inv (power -1 m))
  1788.         (inv (factf a m))
  1789.         (inv (factf (add (inv 2) n (sub a m)) m))
  1790.         (inv (factf (sub (inv 2) a) (- n m)))
  1791.         (inv (factf (add (inv 2) a) (- n m)))
  1792.         (power (sub 1 'ell) (sub 1 a))
  1793.         ($diff (mul 
  1794.             (power (sub 1 'ell) (add a n (inv -2)))
  1795.             ($diff (mul
  1796.                 (power (sub 1 'ell) (inv -2))
  1797.                 fun) 'ell (- n m))) 'ell m)))
  1798.  
  1799. (defun f82
  1800.        (fun m n a)
  1801.        (mul (inv (factf (sub (inv 2) n) m))
  1802.         ;; Was this both inverse?
  1803.         (inv (factf (sub (add (inv 2) m) n) (- n m)))
  1804.         (power 'ell (add n (inv 2)))
  1805.         (power (sub 1 'ell) (sub (add m (inv 2) a) n))
  1806.         ($diff (mul (power (sub 1 'ell)
  1807.                    (sub (sub n a) (inv 2)))
  1808.             ($diff (mul  (power 'ell (inv -2)) fun)
  1809.                    'ell
  1810.                    (- n m)))
  1811.            'ell
  1812.            m)))
  1813.  
  1814. (defun f83
  1815.        (fun m n a)
  1816.        (mul (factf (inv 2) n)
  1817.         (inv (factf (sub (inv 2) a) n))
  1818.         (inv (factf (add (sub (inv 2) a) n) m))
  1819.         (inv (factf (add (inv 2) a) n))
  1820.         (power (sub 1 'ell) (add m n (inv 2)))
  1821.         (power 'ell (sub (add (inv 2) a) n))
  1822.         ($diff (mul (power 'ell (sub (sub (+ m n)  a)(inv 2)))
  1823.             ($diff (mul (power (sub 1 'ell)
  1824.                        (inv -2))
  1825.                     fun)
  1826.                    'ell
  1827.                    n))
  1828.            'ell
  1829.            m)))
  1830.  
  1831. (defun f84
  1832.        (fun m n a)
  1833.        (mul (inv (mul (factf a m) (factf (sub (inv 2) n) n)))
  1834.         (power 'ell (sub 1 a))
  1835.         ($diff (mul (power 'ell (sub (add a m n) (inv 2)))
  1836.             ($diff (mul (power 'ell (inv -2)) fun)
  1837.                    'ell
  1838.                    n))
  1839.            'ell
  1840.            m)))
  1841.  
  1842. (defun f86
  1843.        (fun m n a)
  1844.        (mul (inv (mul (factf (sub (inv 2) n) n)
  1845.               (factf (sub (inv 2) a) (- m n))))
  1846.         (power 'ell (add n (inv 2)))
  1847.         (power (sub 1 'ell)(add (inv 2) a))
  1848.         ($diff (mul (power 'ell a)
  1849.             (power (sub 1 'ell)(sub m a))
  1850.             ($diff (mul (power 'ell
  1851.                        (sub (sub (sub m n) (inv 2)) a))
  1852.                     (power (sub 1 'ell)
  1853.                        (inv -2))
  1854.                     fun) 'ell (- m n)))
  1855.             'ell n)))
  1856.  
  1857.  
  1858. (eval-when (compile)
  1859. (DECLARE-top (unSPECIAL serieslist VAR PAR ZEROSIGNTEST PRODUCTCASE
  1860.             fldeg flgkum listcmdiff checkcoefsignlist ))
  1861.  
  1862. (declare-top (unspecial fun w b l alglist n  c ))
  1863. )